home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / defsys 5.0 / defsys.l < prev    next >
Encoding:
Text File  |  1992-09-02  |  48.3 KB  |  1,338 lines  |  [TEXT/CCL2]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         defsys.l
  3. ; Description:  A portable defsystem facility written in pure Common LISP.
  4. ;               This is a largely extended version of the original
  5. ;               defsystem written by Doug Rand
  6. ; Author:       dougr@eddie.mit.edu, Joachim H. Laubsch (laubsch@hplabs.hp.com)
  7. ; Created:      28-Jul-89
  8. ; Modified:     Tue Aug 11 12:04:54 1992 (Joachim H. Laubsch)
  9. ; Language:     CL
  10. ; Package:      DEFSYSTEM
  11. ;
  12. ;;; *************************************************************************
  13. ;;; Copyright (c) 1989, Hewlett-Packard Company
  14. ;;; All rights reserved.
  15. ;;;
  16. ;;; Use and copying of this software and preparation of derivative works
  17. ;;; based upon this software are permitted.  Any distribution of this
  18. ;;; software or derivative works must comply with all applicable United
  19. ;;; States export control laws.
  20. ;;; 
  21. ;;; This software is made available AS IS, and Hewlett-Packard Company
  22. ;;; makes no warranty about the software, its performance or its conformity
  23. ;;; to any specification.
  24. ;;; 
  25. ;;; Suggestions, comments and requests for improvements are welcome
  26. ;;; and should be mailed to laubsch@hplabs.com.
  27. ;;; *************************************************************************
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (in-package "DEFSYSTEM")
  31. (require "P-defsys")
  32.  
  33. #+:KCL(proclaim '(optimize (speed 1)))
  34. (proclaim '(special *suffixes*))
  35. #-:LUCID
  36. (defvar *LOAD-IF-SOURCE-NEWER* :QUERY)
  37. #+(and :LUCID (not :LCL4.0))
  38. (import 'SYSTEM:*LOAD-IF-SOURCE-NEWER*)
  39. #+(and :LUCID  :LCL4.0)
  40. (import 'LCL:*LOAD-IF-SOURCE-NEWER*)
  41.  
  42. (defstruct (system (:print-function print-system))
  43.   (name "")
  44.   (default-pathname   (pathname "")   :type (or cons pathname))
  45.   (default-package    *package*)
  46.   (needed-systems      nil            :type list)
  47.   (load-before-compile nil            :type list)
  48.   (module-list         nil            :type list)
  49.   (needs-update        nil)
  50.   (modules             (make-hash-table :size 16 :rehash-size 8 :test #'equal))
  51.   (default-load-module t)        ; t means load all
  52.   (memo                nil            :type list)
  53.   ;; generalize to other compilers
  54.   ;; DEFAULT is the Common Lisp compiler
  55.   (compiler            #'compile-file :type function)
  56.   ;; generalize to other loaders
  57.   (loader              #'load         :type function)
  58.   (suffixes            *suffixes*     :type list)
  59.   #+:LCL4.0
  60.   (source-file         nil)
  61.   (documentation       nil             :type (or NULL string))
  62.   )
  63.  
  64. (defun print-system (system stream level)
  65.   (declare (ignore level))
  66.   (format stream "#<System ~A>" (system-name system)))
  67.  
  68. (defstruct (module (:print-function print-module))
  69.   (name "")
  70.   (load-before-compile nil)
  71.   (compile-only nil)
  72.   (load-after nil)
  73.   (recompile-on nil)
  74.   (pathname nil)
  75.   (dtm 0)
  76.   (package nil)
  77.   (in-process nil)
  78.   (being-loaded nil)            ; to avoid recursion in loading
  79.   (loaded nil)
  80.   (type )
  81.   (source-path)                ; cache module-source-file
  82.   (binary-path)                ; cache module-binary-file
  83.   ;; generalize to other compilers
  84.   (compiler nil :type (or NULL function))
  85.   ;; DEFAULT is the Common Lisp compiler
  86.   ;; generalize to other loaders
  87.   (loader  nil :type (or NULL function))
  88.   (suffixes nil :type list)
  89.   )
  90.  
  91. (defmacro domodules ((module system &key recursive-p) &rest body)
  92.   (let ((s (gentemp)))
  93.     `(let* ((,s ,system))
  94.       (dolist (system-name ,(if recursive-p
  95.                 `(system-needed-systems* ,s)
  96.                   `(list ,s)))
  97.     (let ((system (find-system system-name)))
  98.       (dolist (module-name (system-module-list system))
  99.         (let ((,module (module-source-file (find-module module-name system)
  100.                            system)))
  101.           . ,body)))))))      
  102.  
  103. (defmacro with-package ((module system) &rest body)
  104.   `(let ((p (or (module-package ,module) (system-default-package ,system))))
  105.     (if p
  106.     (let ((*package* (if (typep p 'PACKAGE)
  107.                  p
  108.                (or (find-package p)
  109.                    (error "Unknown package ~S" p)))))
  110.       .,body)
  111.       (progn .,body))))
  112.  
  113. (proclaim '(inline module-load-only))
  114. (defun module-load-only (module)
  115.   (member (module-type module) '(:LISP-SOURCE :LISP-BINARY)))
  116.  
  117. (proclaim '(inline module-not-to-be-loaded))
  118. (defun module-not-to-be-loaded (module)
  119.   (declare (type module module))
  120.   (or (module-compile-only module)
  121.       (member (module-type module)
  122.           '(:LISP-EXAMPLE :TEXT))))
  123.  
  124. (proclaim '(inline module-not-to-be-compiled))
  125. (defun module-not-to-be-compiled (module)
  126.   (declare (type module module))
  127.   (member (module-type module)
  128.       '(:LISP-BINARY :LISP-SOURCE :LISP-EXAMPLE :TEXT)))
  129.  
  130. (defun print-module (module stream level)
  131.   (declare (ignore level))
  132.   (format stream "#<Module ~A>" (module-name module)))
  133.  
  134. (defvar *all-systems* nil)
  135. (defvar *loaded-systems* nil)
  136.  
  137. (defmacro undefsystem (system-name)
  138.   (if (symbolp system-name)
  139.       `(let ((system (find-system ',system-name nil)))
  140.     (if system
  141.         (setq *all-systems* (remove system *all-systems* :key #'cdr))
  142.       (warn "System ~S was not defined." ',system-name)))
  143.     (error "Argument should be a symbol, not ~S." system-name))
  144.   )
  145.  
  146. (defvar *relative-binary-namestring* "")
  147.  
  148. (defun canonical-pathname (key arg &aux (sep #+:CCL #\: #-:CCL #\/))
  149.   ;; If the pathname is a string, this will be the source directory.
  150.   ;; The binary directory will default relative to it, appending the string
  151.   ;; *relative-binary-namestring*
  152.   (flet ((wrng-args ()
  153.        (error "Pathname should be a string or a dotted pair of strings, not~% ~S ~S .."
  154.           key arg)))
  155.     (flet ((append-seperator? (s)
  156.          (let ((ln (length s)))
  157.            (if (zerop ln)
  158.            (string sep)
  159.          (if (let ((end (elt s (1- ln))))
  160.                        (or (char= end sep)
  161.                            #+MCL (char= end #\;)
  162.                            ))
  163.              s
  164.            (concatenate 'string s (string sep)))))))
  165.       (flet ((pre-process-pathname (s)
  166.            (let* ((s (expand-file-name s))
  167.               (ln (length s)))
  168.          (if (zerop ln)
  169.              (wrng-args)
  170.            (append-seperator?
  171.             (concatenate 'string
  172.                  (append-seperator? s)
  173.                  *relative-binary-namestring*))))))
  174.     (flet ((expand&append-sep (s)
  175.          (append-seperator? (expand-file-name s))))
  176.       (or (typecase arg
  177.         (STRING (cons (expand&append-sep arg) (pre-process-pathname arg)))
  178.         (CONS (if (and (stringp (car arg))
  179.                    (stringp (cdr arg)))
  180.               (cons (expand&append-sep (car arg))
  181.                 (expand&append-sep (cdr arg)))))
  182.         (PATHNAME arg)
  183.         (T nil))
  184.           (wrng-args)))))))
  185.  
  186. (defun pre-process-options (whole-key-value-list modules-p &aux all-keys)
  187.   (flet ((canonical-modules (ms)
  188.        (let ((cms (if (or (stringp ms)
  189.                   (and (consp ms)
  190.                    (symbolp (car ms))
  191.                    (or (eq T (cadr ms))
  192.                        (every #'(lambda (m) (stringp m))
  193.                           (cdr ms)))))
  194.               (list ms)
  195.             (if (consp ms)
  196.                 ms
  197.               (error "Wrong syntax for Module ~S" ms)))))
  198.          (do ((cmtl cms (cdr cmtl))) ((null cmtl))
  199.            (when (member (car cmtl) (cdr cmtl) :test #'equal)
  200.          (error "Multiply mentioned module ~S in ~S."
  201.             (car cmtl) (cdr whole-key-value-list))))
  202.          cms))
  203.      
  204.      (av (key val keylist)        ; add a value
  205.        (let ((v (if (consp val) val (list val))))
  206.          (do ((tl keylist (cddr tl)))
  207.          ((null tl) (cons key (cons v keylist)))
  208.            (when (eq (car tl) key)
  209.          (let* ((tl1 (cdr tl))
  210.             (v1 (if (consp (car tl1)) (car tl1) (list (car tl1)))))
  211.            (setf (cadr tl) (remove-duplicates (append v v1)
  212.                               :from-end t
  213.                               :test #'equal))
  214.            (return keylist))))))
  215.  
  216.      (canonical-systems (arg)
  217.        (if (listp arg) arg (list arg)))
  218.      (wrng-arg (key arg)
  219.        (error "The system option ~S (expecting a symbol or function) was given: ~S instead"
  220.           key arg)))
  221.     
  222.     (labels ((pre-process-tail (key-value-list)
  223.            (when key-value-list
  224.          (let ((key (car (the cons key-value-list))))
  225.            (if (keywordp key)
  226.                (if (consp (cdr (the cons key-value-list)))
  227.                (let ((arg (cadr (the cons key-value-list)))
  228.                  (Rargs (cddr key-value-list)))
  229.                  (if (member key all-keys)
  230.                  (error "Multiple use of keyword ~S ~S ..." key arg)
  231.                    (push key all-keys))
  232.                  (case key
  233.                    ((:default-pathname :pathname)
  234.                 (list* key
  235.                        (canonical-pathname key arg)
  236.                        (pre-process-tail Rargs)))
  237.                    ((:load-before-compile :needed-systems)
  238.                 (list* key
  239.                        (if modules-p
  240.                        (canonical-modules arg)
  241.                      (canonical-systems arg))
  242.                        (pre-process-tail Rargs)))
  243.                    ((:recompile-on :load-after)
  244.                 (list* key
  245.                        (canonical-modules arg)
  246.                        (pre-process-tail Rargs)))
  247.                    ((:package :default-package)
  248.                 (list* key
  249.                        (string arg)
  250.                        (pre-process-tail Rargs)))
  251.                    ((:compiler :loader)
  252.                 (list* key
  253.                        (typecase arg
  254.                      (SYMBOL arg)
  255.                      (CONS (case (car (the cons arg))
  256.                          ((FUNCTION QUOTE) (eval arg))
  257.                          (T (wrng-arg key arg))))
  258.                      (T (wrng-arg key arg)))
  259.                        (pre-process-tail Rargs)))
  260.                    (:suffixes
  261.                 (list* key
  262.                        (if (consp arg)
  263.                        arg
  264.                      (cons arg arg))
  265.                        (pre-process-tail Rargs)))
  266.                    (t (list* key
  267.                      (cadr key-value-list)
  268.                      (pre-process-tail Rargs)))))
  269.              (error "Odd length option list ~S." key-value-list))
  270.              (error
  271.               "Keyword expected in module-description ~S instead of ~S."
  272.               (cdr whole-key-value-list) key))))))
  273.       (when modules-p
  274.     (let ((p1 (position ':load-always whole-key-value-list)))
  275.       (when p1
  276.         (let* ((p1-tail (nthcdr (1+ p1) whole-key-value-list))
  277.            (arg (canonical-modules (car p1-tail))))
  278.           (setf whole-key-value-list
  279.             (av ':load-before-compile
  280.             arg
  281.             (av ':load-after
  282.                 arg
  283.                 (nconc (subseq whole-key-value-list 0 p1)
  284.                    (cdr p1-tail)))))))))
  285.       (pre-process-tail whole-key-value-list))))
  286.  
  287.  
  288. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  289. ;;                                  defsystem
  290. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  291.  
  292. (defmacro defsystem (system-name options &body modules)
  293.   (check-type system-name symbol)
  294.   (check-type options list)
  295.   `(let* ((system-construct (append '(:name ,system-name)
  296.                     ',(pre-process-options options nil)))
  297.       mod-list
  298.       (system (apply #'make-system system-construct))
  299.       (loader (system-loader system))
  300.       (compiler (system-compiler system))
  301.       (suffixes (system-suffixes system))
  302.       (system-mods (system-modules system)))
  303.     (dolist (module ',modules)
  304.       (let* ((mod-construct
  305.           (if (consp module)
  306.           (cons ':name module)
  307.         (if (stringp module)
  308.             (list ':name module)
  309.           (error "Expecting a module description instead of: ~S."
  310.              module))))
  311.          (module-structure
  312.           (apply #'make-module
  313.              (pre-process-options mod-construct t)))
  314.          (module-name (module-name module-structure)))
  315.     (if (member module-name mod-list :test #'equal)
  316.         (error "Module ~S multiply defined." module-name)
  317.       (push module-name mod-list))
  318.     (unless (module-loader module-structure)
  319.       (setf (module-loader module-structure)
  320.         (if (and (module-type module-structure)
  321.              (member (module-type module-structure)
  322.                  '(:LISP :LISP-EXAMPLE)))
  323.             #'load
  324.             loader)))
  325.     (unless (module-type module-structure)
  326.       (setf (module-type module-structure) ':LISP))
  327.     (unless (module-compiler module-structure)
  328.       (setf (module-compiler module-structure) compiler))
  329.     (unless (module-suffixes module-structure)
  330.       (setf (module-suffixes module-structure) suffixes))
  331.     (setf (gethash (module-name module-structure) system-mods)
  332.           module-structure) ) )
  333.     (setf (system-module-list system) (nreverse mod-list))
  334.     #+LCL4.0
  335.     (when (boundp '*load-pathname*)
  336.       (setf (system-source-file system) (namestring *load-pathname*)))
  337.     (redefine-system ',system-name system)      
  338.     ',system-name
  339.     )
  340.   )
  341.  
  342. (defun redefine-system (system-name system)
  343.   (let ((system-entry (assoc system-name *all-systems*)))
  344.     (if system-entry
  345.     (let* ((old-system (cdr system-entry))
  346.            (old-modules (system-modules old-system))
  347.            (loaded t))
  348.       ;; find out whether the old system was loaded
  349.       (dolist (module-name (system-module-list system))
  350.         (let ((md (gethash module-name old-modules)))
  351.           (if (and md (module-loaded md))
  352.         (let ((new-module (find-module module-name system)))
  353.           (if (and (subsetp (module-load-before-compile new-module)
  354.                     (module-load-before-compile md)
  355.                     :test #'equal)
  356.                (subsetp (module-load-after new-module)
  357.                     (module-load-after md)
  358.                     :test #'equal)
  359.                (subsetp (module-recompile-on new-module)
  360.                     (module-recompile-on md)
  361.                     :test #'equal))
  362.               (setf (module-loaded new-module) t
  363.                 (module-dtm new-module) (module-dtm md))
  364.             (setf loaded nil)))
  365.         (setf loaded nil))))
  366.       (unless loaded
  367.         (setf *loaded-systems* (delete system-name *loaded-systems*)))
  368.       (setf (cdr system-entry) system))  
  369.       (push (cons system-name system) *all-systems*))))
  370.  
  371. ;----------------------------------------------------------------------------;
  372. ; load-system
  373. ;------------
  374. ; Exported function to load a system
  375. ; 
  376. (defun load-system (system-name &key reload (include-components T) preview
  377.                 (if-source-newer :load-source)
  378.                 (level 0)
  379.                 (memo-tag (list nil));; a unique id of this call
  380.                 &aux *load-verbose*)
  381.   (declare (special *load-verbose*
  382.             include-components if-source-newer level memo-tag))
  383.   (flet ((load-modules (modules system)
  384.        (dolist (module modules)
  385.          (let ((a-module (find-module module system)))
  386.            ;; If already loaded then only reload if needed
  387.            (unless (module-not-to-be-loaded a-module)
  388.          (load-if-needed a-module system reload preview))))))
  389.     (let* ((*load-if-source-newer* if-source-newer)
  390.        (system-entry (assoc system-name *all-systems*))
  391.        (system (if system-entry
  392.                (cdr system-entry)
  393.              (load-system-definition system-name))))
  394.       ;; if we have already loaded this system with the same memo-tag skip rest
  395.       (when (eq (system-memo system) memo-tag)
  396.     (return-from load-system (values)))
  397.       (unless preview
  398.     (format T "~%~%;;; ~V@TLoading system ~S" level system-name))
  399.       ;; Load subsystems
  400.       (load-needed-systems system reload preview)
  401.       ;; if there is a :default-load-module then load only it
  402.       (let ((lmod (system-default-load-module system)))
  403.     (when lmod            ; NIL means: don't load any module
  404.       (load-modules
  405.        (if (consp lmod)
  406.            lmod
  407.          (if (eq lmod T)        ; T   means: load ALL modules
  408.          (system-module-list system)
  409.            (list lmod)))
  410.        system)))
  411.       (unless preview
  412.     (format T "~%;;; ~V@TDone loading system ~S~%" level system-name)
  413.     (pushnew system-name *loaded-systems*)
  414.     (setf (system-needs-update system) nil))
  415.       (setf (system-memo system) memo-tag)
  416.       (values))))
  417.  
  418. (defun load-needed-systems (system reload preview)
  419.   (declare (special include-components if-source-newer level memo-tag))
  420.   (dolist (subsystem-name (system-needed-systems system))
  421.       (let ((subsystem (find-system subsystem-name nil)))
  422.     (unless subsystem
  423.       (setq subsystem (load-system-definition subsystem-name :errorp t)))
  424.     (when (and include-components
  425.            (or reload
  426.                (multiple-value-bind (loaded? needs-reload?)
  427.                (SYSTEM-LOADED-P subsystem-name)
  428.              (or (not loaded?)
  429.                  needs-reload?))))
  430.       (load-system subsystem-name
  431.                :reload reload
  432.                :include-components include-components
  433.                :preview preview
  434.                :if-source-newer if-source-newer
  435.                :level (+ level 2)
  436.                :memo-tag memo-tag))))
  437.   )
  438.  
  439. ;----------------------------------------------------------------------------;
  440. ; load-if-needed
  441. ;---------------
  442. ; load the module of the system, possibly again, possibly just previewing
  443. ; returns no value
  444.  
  445. (defun load-if-needed (module system &optional reload preview)
  446.   (flet ((do-load (path)
  447.        ;; never force to reload any :load-after module
  448.        (let ((load-after (module-load-after module))
  449.          (needed-systems+ (system-needed-systems*-aux system)))
  450.          (dolist (m load-after)
  451.            (if (stringp m)
  452.            (multiple-value-bind (mod system)
  453.                (find-module-among-systems m needed-systems+)
  454.              (load-if-needed mod system nil preview))
  455.          (load-from-system m nil preview t))))
  456.        (if preview
  457.            (format T "~%;;; Need to load: ~S" path)
  458.          (let ((loader (module-loader module)))
  459.            (unless (or (functionp loader)
  460.                (and (symbolp loader) (fboundp loader)))
  461.          (error "Load function ~S (of ~S) is not a defined function."
  462.             loader system))
  463.            (format T "~%;;; Loading file ~S" path)
  464.            (prog1 (with-package (module system)
  465.             (funcall loader path))
  466.          (setf (module-loaded module) T
  467.                (module-dtm module) (file-write-date path)))))))
  468.     (let ((path (get-pathname module system)) R)
  469.       (if (null path)
  470.       (module-not-found module system)
  471.     (when (and (not (module-being-loaded module))
  472.            (or reload
  473.                (not (module-loaded module))
  474.                (module-needs-reload-p* module system)))
  475.       (unwind-protect (setf (module-being-loaded module) t
  476.                 R (do-load path))                
  477.         (setf (module-being-loaded module) nil))))
  478.       R)))
  479.  
  480. (defun load-from-system (module-ref reload preview &optional test-load?)
  481.   ;; MODULE-REF: (<SYSTEM> m1 m2 ...) || (<SYSTEM> t)
  482.   (if (consp module-ref)
  483.       (let ((modules (rest module-ref)))
  484.     (if (eq (car (the cons modules)) 'T)
  485.         (load-system (car (the cons module-ref))
  486.              :reload reload :preview preview)
  487.       (let ((sys (find-system! (car (the cons module-ref)))))
  488.         ;; (load-needed-systems sys reload preview)
  489.         (dolist (module-name modules)
  490.           (let ((module (find-module module-name sys)))
  491.         (when (not (and test-load?
  492.                 (member (module-type module)
  493.                     '(:LISP-EXAMPLE :TEXT))))
  494.           (load-if-needed module sys reload preview))))
  495.         )))
  496.     (error "~S is not a module description" module-ref)))
  497.     
  498.     
  499. ;----------------------------------------------------------------------------;
  500. ; compile-system
  501. ;---------------
  502. ; Exported function to compile a system
  503. ; will try to locate the definition first
  504.  
  505. (defun compile-system (system-name &rest keyword-pairs
  506.                    &key reload recompile
  507.                    (include-components T) preview
  508.                    (memo-tag (list nil)) ;; a unique id of this call
  509.                    &allow-other-keys
  510.                    &aux system compiled-modules *load-verbose*
  511.                    (level 0))
  512.   (declare (special system compiled-modules *load-verbose* level)
  513.        (type symbol system-name))
  514.   (check-type system-name symbol)       
  515.   (let ((system-entry (assoc system-name *all-systems*)))
  516.     ;; try to find and load the system definition
  517.     (setq system (if system-entry
  518.              (cdr system-entry)
  519.            (load-system-definition system-name :errorp t)))
  520.     ;; if we have already compiled this system with the same memo-tag skip rest
  521.     (when (eq (system-memo system) memo-tag)
  522.       (return-from compile-system (values)))
  523.     ;; Recompile included systems
  524.     (dolist (subsystem-name (system-needed-systems system))
  525.       (let ((subsystem (find-system! subsystem-name)))
  526.     (when include-components
  527.       (unless (eq (system-memo subsystem) memo-tag)
  528.         (unless preview (format T "~%;;; Compiling System ~S" subsystem-name))
  529.         (compile-system subsystem-name
  530.                 :reload reload :recompile recompile
  531.                 :include-components include-components
  532.                 :preview preview :memo-tag memo-tag)))))
  533.     ;; Compile modules:
  534.     ;; compiled-modules = list of module-names that needed to be compiled
  535.     (dolist (module (system-module-list system))
  536.       (unless (module-not-to-be-compiled (find-module module system))
  537.     (multiple-value-bind (d c)
  538.         (apply #'compile-if-needed
  539.            module
  540.            (if compiled-modules
  541.                nil        ; we have already done the dependencies
  542.              #'(lambda ()    ; Load Compile subsystem dependencies
  543.              (dolist (subsystem-name (system-load-before-compile system))
  544.                (let ((subsystem (find-system! subsystem-name)))
  545.                  (when (or reload
  546.                        (not (member subsystem-name *loaded-systems*))
  547.                        (system-needs-update subsystem))
  548.                    (load-system subsystem-name
  549.                         :reload reload
  550.                         :include-components t ; always load needed systems
  551.                         :preview preview))))))
  552.            keyword-pairs)
  553.       (declare (ignore d))
  554.       (when c (push module compiled-modules)))))
  555.     (setf (system-memo system) memo-tag)
  556.     (if compiled-modules
  557.     (if preview
  558.         (format t "~%;;; In System ~S, need to compile:~%;;; ~{~A ~}"
  559.             system-name (nreverse compiled-modules))
  560.       (format t "~%;;; Compiled System ~S" system-name))
  561.       (format t "~%;;; System ~S needs no compilation." system-name))
  562.     (values)))
  563.  
  564. ;----------------------------------------------------------------------------;
  565. ; compile-if-needed
  566. ;------------------
  567. ; return 2 values
  568. ;   (1) the date/time of the latest compilation
  569. ;   (2) whether or not the module was actually compiled
  570.  
  571. (defun compile-if-needed (module-name
  572.               ;; before really compiling possibly do this
  573.               prep-thunk
  574.               &rest keyword-pairs
  575.               &key reload recompile preview 
  576.                    needed    ; if the user wants do it!
  577.               &allow-other-keys
  578.               &aux bpath sdtm bdtm (ddtm 0))
  579.   (declare (special system compiled-modules))
  580.   (macrolet ((module-set (MS-desc system)
  581.            ;; MS-desc: (<SYSTEM> m1 m2 ...) || (<SYSTEM> t)
  582.            `(let ((ms (cdr (the cons ,MS-desc))))
  583.          (if (eq (car (the cons ms)) 'T)
  584.              (system-module-list ,system)
  585.            ms))))
  586.     (flet ((load-dependees (modules systems)
  587.          (dolist (name modules)
  588.            (if (stringp name)
  589.            (multiple-value-bind (m s)
  590.                (find-module-among-systems name systems)
  591.              (load-if-needed m s reload preview))
  592.          (load-from-system name reload preview t)))))
  593.       (let* ((module  (find-module module-name system))
  594.          (spath (let ((p (module-source-file module system)))
  595.               (or p (error "Can't find the source file for ~S.~%" module-name)))))
  596.     (remf keyword-pairs ':needed)    ; just for call from compile-module
  597.     ;; Do our dependents unless this module is being processed
  598.     (unless (or (module-in-process module) (null (module-recompile-on module)))
  599.       (unwind-protect
  600.            ;; We don't want to recurse infinitely if one module has
  601.            ;; a reciprocal compile relation with another so we set the
  602.            ;; in-process flag to cause this to bottom out.  The
  603.            ;; unwind-protect makes sure it's cleaned up on error cases.
  604.            (let ((needed-systems* (system-needed-systems*-aux system)))
  605.          (setf (module-in-process module) T)
  606.          (dolist (mod (module-recompile-on module))
  607.            (if (stringp mod)
  608.                (multiple-value-bind (m system)
  609.                (find-module-among-systems mod needed-systems*)
  610.              (declare (special system))
  611.              (if (member mod compiled-modules :test #'equal)
  612.                  (setq ddtm (max (file-write-date
  613.                           (module-binary-file m system))
  614.                          ddtm))
  615.                (multiple-value-bind (date compiled?)
  616.                    (apply #'compile-if-needed
  617.                       mod
  618.                       prep-thunk
  619.                       :allow-other-keys t
  620.                       keyword-pairs)
  621.                  (setq ddtm (max date ddtm))
  622.                  (if compiled? (setq prep-thunk nil)))))
  623.              (let ((system (find-system (car mod))))
  624.                (declare (special system))
  625.                (dolist (module-name (module-set mod system))
  626.              (unless (module-not-to-be-compiled
  627.                   (find-module module-name system)) 
  628.                (multiple-value-bind (date compiled?)
  629.                    (apply #'compile-if-needed
  630.                       module-name
  631.                       prep-thunk
  632.                       :allow-other-keys t
  633.                       keyword-pairs)
  634.                  (setq ddtm (max date ddtm))
  635.                  (if compiled? (setq prep-thunk nil)))))))))
  636.         (setf (module-in-process module) nil)))
  637.     ;; compile the module if its binary is older than its source or dependee
  638.     (setq bpath (module-binary-file module system)
  639.           sdtm (file-write-date spath)
  640.           bdtm (if (probe-file bpath) (file-write-date bpath) 0))
  641.     (if (and (or needed (< bdtm sdtm) (< bdtm ddtm)
  642.              (and recompile (not (member module-name compiled-modules))))
  643.          (not (module-in-process module)))
  644.         ;; Recompiling.. load necessary files
  645.         (let ((needed-systems* nil)
  646.           (recompile-on (module-recompile-on module))
  647.           (load-before-compile (module-load-before-compile module)))
  648.           ;; Now, do the postponed load of the subsystems
  649.           (when prep-thunk (funcall prep-thunk))
  650.           (when (or recompile-on load-before-compile)
  651.         (setq needed-systems* (system-needed-systems*-aux system)))
  652.           (load-dependees recompile-on needed-systems*)
  653.           (load-dependees load-before-compile needed-systems*)
  654.           (let ((universal-time (get-universal-time)))
  655.         (unless preview
  656.           (format T "~%;;; Compiling Module ~S (of ~S) to ~S"
  657.               (module-name module) (system-name system) (namestring bpath))
  658.           (let ((compiler (module-compiler module)))
  659.             (unless (or (functionp compiler) (and (symbolp compiler) (fboundp compiler)))
  660.               (error "Compile function ~S (of ~S) is not a defined function."
  661.                  compiler system))
  662.               (let (compiled?)
  663.             (unwind-protect
  664.                  (setq compiled?
  665.                    (with-package (module system)
  666.                      (apply compiler spath
  667.                         :output-file bpath
  668.                         :allow-other-keys t
  669.                         keyword-pairs)))
  670.               ;; if an error occurs during compilation remove the partially written
  671.               ;; file, that some compiler may leave around
  672.               (when (and (not compiled?) (probe-file bpath))
  673.                 (delete-file bpath)))))
  674.           (terpri))
  675.         (setf (system-needs-update system) T)
  676.         ;; recompiling produces a new file so it is up to date
  677.         ;; until the point of START of compilation
  678.         (values universal-time t)))
  679.       ;; Not recompiling or in process..
  680.       (values (max bdtm sdtm) nil))))))
  681.  
  682. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  683. ;;                                  Pathnames
  684. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  685.  
  686. (proclaim '(inline path-source-path path-bin-path))
  687. (defun path-source-path (mpath)
  688.   (if (consp mpath) (car (the cons mpath)) mpath))
  689.  
  690. (defun path-bin-path (mpath)
  691.   (if (consp mpath) (cdr (the cons mpath)) mpath))
  692.  
  693. ;; return nil if file is not found
  694. ;; otherwise return the pathname of the newer file, unless
  695. ;; *LOAD-IF-SOURCE-NEWER* is :LOAD-BINARY it will the binary instead
  696.  
  697. (defun get-pathname (module system)
  698.   (let* ((module-name (make-pathname :name (module-name module)))
  699.      (mpath (or (module-pathname module)
  700.             (setf (module-pathname module)
  701.               (system-default-pathname system))))
  702.      (spath (path-source-path mpath))
  703.      (bpath (path-bin-path mpath))
  704.      (suffixes (module-suffixes module))     
  705.      (sname (merge-pathnames (merge-pathnames module-name spath)
  706.                  (make-pathname :type (car suffixes))))
  707.      (bname (merge-pathnames (merge-pathnames module-name bpath)
  708.                  (make-pathname :type (cdr suffixes)))))
  709.     (if (probe-file sname)
  710.     (let ((sdtm (file-write-date sname)))
  711.       (if (probe-file bname)
  712.           (let ((bdtm (file-write-date bname)))
  713.         ;; Both exist take newer
  714.         (if (> sdtm bdtm)
  715.             (if (eq *LOAD-IF-SOURCE-NEWER* :LOAD-BINARY)
  716.             bname
  717.               sname)
  718.           bname))
  719.         sname))
  720.       (if (probe-file bname)
  721.       bname
  722.     nil))))
  723.  
  724. (defun module-source-file (module system)
  725.   (declare (type module module))
  726.   (or (module-source-path module)
  727.       (let* ((mpath (or (module-pathname module)
  728.             (setf (module-pathname module)
  729.                   (system-default-pathname system))))
  730.          (dir+name (merge-pathnames
  731.             (make-pathname :name (module-name module))
  732.             (path-source-path mpath)))
  733.          (source-path (merge-pathnames
  734.                dir+name
  735.                (make-pathname
  736.                 :type (car (module-suffixes module)))))
  737.          (probed-path (or (probe-file source-path)
  738.                   (probe-file dir+name)
  739.                   (return-from module-source-file nil))))
  740.     (setf (module-source-path module) probed-path))))
  741.  
  742. (defun module-binary-file (module system)
  743.   (declare (type module module))
  744.   ;; cache the value
  745.   (or (module-binary-path module)
  746.       (let ((mpath (or (module-pathname module)
  747.                (setf (module-pathname module)
  748.                  (system-default-pathname system)))))
  749.     (setf (module-binary-path module)
  750.           (merge-pathnames
  751.            (make-pathname :name (module-name module)
  752.                   :type (cdr (module-suffixes module)))
  753.            (path-bin-path mpath))))) )
  754. ;----------------------------------------------------------------------------;
  755. ; compile-module
  756. ;---------------
  757. ; Compile a module and any modules which this module depends on.
  758. ;  An attempt is made to find the system where this module was 
  759. ;  defined. By default needed modules which are loaded will 
  760. ;  not be reloaded.
  761.  
  762. (defun compile-module (module-name
  763.                &rest keyword-pairs
  764.                &key ((:system system-name)) reload preview
  765.                &allow-other-keys)
  766.   (let ((system (find-system-for-module module-name system-name))
  767.     compiled-modules)
  768.     (declare (special system compiled-modules))
  769.     (apply
  770.      #'compile-if-needed
  771.      module-name
  772.      #'(lambda ()
  773.      (dolist (subsystem-name (system-load-before-compile system))
  774.        (load-system subsystem-name
  775.             :reload reload
  776.             :include-components t ; always load needed systems
  777.             :preview preview)))
  778.      :needed t            ; recompile because the user wants it
  779.      keyword-pairs)
  780.     (values)    
  781.     ))
  782.  
  783. ;----------------------------------------------------------------------------;
  784. ; load-module
  785. ;------------
  786. ; load a module.  By default, the module will be reloaded.  The keyword argument 
  787. ; :reload may be used to avoid reload of the module and possibly all modules this 
  788. ; module depends on.  If the module description contains any :load-after
  789. ; modules, these will also be reloaded.
  790. (defun load-module (module-name
  791.             &key
  792.             ((:system system-name))
  793.             (if-source-newer :load-source)
  794.             (reload t) preview
  795.             &aux
  796.             (level 0)
  797.             (*load-if-source-newer* if-source-newer)
  798.             (system (find-system-for-module module-name system-name))
  799.             (module (find-module module-name system)))
  800.   (declare (special level))
  801.   (when (or reload (not (module-loaded module)))
  802.     (load-if-needed module
  803.             system
  804.             reload
  805.             preview
  806.             )))
  807.  
  808. (defun find-system-for-module (module-name system-name)
  809.   (cond ((null system-name)
  810.      ;; try to find one
  811.      (multiple-value-bind (module sys)
  812.          (find-module-among-systems
  813.           module-name (mapcar #'car *all-systems*))
  814.          (declare (ignore module))
  815.        sys))
  816.     ((symbolp system-name) (find-system! system-name))
  817.     (t (error "~S should be a symbol naming a defined system."
  818.           system-name))))
  819.  
  820. ;----------------------------------------------------------------------------;
  821. ; show-system
  822. ;------------
  823. ; The function {\tt show-system} produces a pretty output of the system
  824. ; description.
  825.  
  826. (defun show-system (system-name &optional (stream T))
  827.   (macrolet ((show (string val) `(when ,val (format stream ,string ,val))))
  828.     (let* (#+(and :LUCID (not :LCL4.0)) ( SYSTEM::*GC-SILENCE* T )
  829.            #+(and :LUCID :LCL4.0)       ( LCL:*GC-SILENCE* T )
  830.        #+Allegro ( EXCL::*GCPRINT* nil )
  831.        (system (find-system system-name))
  832.        (dashes "~%;;; ---------------------------------")
  833.        (system-path (system-default-pathname system))
  834.        *print-circle*)
  835.       (declare (type system system))
  836.       (format stream "~?~%;;; System: ~S is " dashes () system-name)
  837.       (multiple-value-bind (loaded? needs-reload?)
  838.       (SYSTEM-LOADED-P system-name)
  839.     (format stream "~:[not ~;~]loaded." loaded?)
  840.     (when loaded?
  841.       (format stream "~%;;; It ~:[does'nt need~;needs~] to be reloaded." needs-reload?))
  842.     (let ((lm (system-default-load-module system)))
  843.       (unless (eq lm 'T) (format T "~%;;; Default-load-module: ~S" lm)))
  844.     (show "~%;;; ~A" (system-documentation system))
  845.     (show "~%;;; Load-before-compile: ~{~S ~}" (system-load-before-compile system))
  846.     (show "~%;;; Needed Systems:      ~{~S ~}" (system-needed-systems system))
  847.     (show "~%;;; Default Package:     ~S" (system-default-package system))
  848.     (show "~%;;; Suffixes:            ~S" (system-suffixes system))
  849.     (unless (equal (pathname "") system-path)
  850.       (if (consp system-path)
  851.           (progn
  852.         (format stream "~%;;; Default Source Path:    ~S" (car system-path))
  853.         (format stream "~%;;; Default Binary Path:    ~S"
  854.             (cdr system-path)))
  855.         (format stream "~%;;; Default Path:    ~S" system-path)))
  856.  
  857.     #+:LCL4.0 (show "~%;;; Source file:     ~S" (system-source-file system))
  858.     (dolist (module-name (system-module-list system))
  859.       (show-module module-name :system system-name :verbose nil))
  860.     (system-circular-p system-name ':load-before-compile)
  861.     (system-circular-p system-name ':load-after)
  862.     (format stream dashes)
  863.     (values)))))
  864.  
  865. (defun show-module (module-name &key (system nil system-p) (verbose T) (stream T))
  866.   (macrolet ((show (string val) `(when ,val (format stream ,string ,val))))
  867.     (multiple-value-bind (module system)
  868.     (if system-p
  869.         (values (find-module module-name (find-system system))
  870.             (find-system system))
  871.       (find-module-among-systems
  872.        module-name (mapcar #'car *all-systems*)))
  873.       (let ((system-path (system-default-pathname system)))
  874.     (format stream "~%;;; Module: ~S~:[~; (of ~S)~]"
  875.         module-name verbose (system-name system))
  876.     (let ((type (module-type module)))
  877.       (unless (eq type :lisp) (format t " (type ~S)" (module-type module))))
  878.     (show " Package: ~S" (module-package module))
  879.     (format stream "~48,8T~:[Not ~;~]Loaded" (module-loaded module))
  880.     (let* ((spath  (module-source-file module system))
  881.            (bpath  (probe-file (module-binary-file module system)))
  882.            (sdtm   (and spath (file-write-date spath)))
  883.            (btm    (and bpath (file-write-date bpath)))
  884.            (mpath  (path-source-path (module-pathname module))))
  885.       (if spath
  886.           (progn
  887.         (if (null btm)
  888.             (unless (module-not-to-be-compiled module)
  889.               (format stream "  Needs Compilation"))
  890.           (when (> sdtm btm)
  891.               (format stream "  Needs Recompile")))
  892.         (when (and (module-loaded module)
  893.                (module-needs-reload-p module system))
  894.           (format stream "  Needs Reload")))
  895.         (format stream "~%;;;    Source not found in ~S"
  896.             mpath))
  897.       (show "~%;;;    Compile-only: ~S" (module-compile-only module))
  898.       (let* ((Load-before-compile (module-load-before-compile module))
  899.          (Load-after (module-load-after module))
  900.          (Load-always (intersection Load-before-compile Load-after :test #'equal)))
  901.         (show "~%;;;    Load-always: ~{~S ~}" Load-always)
  902.         (show "~%;;;    Load-before-compile: ~{~S ~}"
  903.           (set-difference Load-before-compile Load-always :test #'equal))
  904.         (show "~%;;;    Load-after: ~{~S ~}"
  905.           (set-difference Load-after Load-always :test #'equal)))
  906.       (show "~%;;;    Recompile-on: ~{~S ~}" (module-recompile-on module))
  907.       (unless (or (null mpath)
  908.               (equal mpath (path-source-path system-path)))
  909.         (format stream "~%;;;    Pathname: ~S" mpath))
  910.       (unless (equal (module-suffixes module) (system-suffixes system))
  911.         (format stream "~%;;;    Suffixes: ~S" (module-suffixes module))))
  912.     (values)))))
  913.  
  914. ;----------------------------------------------------------------------------;
  915. ; module-needs-reload-p
  916. ;----------------------
  917. ; return T if module is not loaded or it is loaded but either the binary or
  918. ; the source is younger than the loaded version
  919.  
  920. (defun module-needs-reload-p (module system)
  921.   (declare (type module module) (type system system))
  922.   (unless (module-not-to-be-loaded module)
  923.     (if (module-loaded module)
  924.     (let ((mdtm   (module-dtm module))
  925.           (spath  (module-source-file module system)))
  926.       #-:KCL (declare (fixnum mdtm) (pathname spath))
  927.       (when spath
  928.         (if (> (file-write-date spath) mdtm)
  929.         ;; the source is more recent ==> T
  930.         (return-from module-needs-reload-p
  931.           (setf (system-needs-update system) t))
  932.           ;; the source is older, how about the binary?
  933.           (let ((bpath (module-binary-file module system)))
  934.         (return-from module-needs-reload-p
  935.           (if (and (probe-file bpath)
  936.                (> (file-write-date bpath) mdtm))
  937.               ;; the binary is more recent ==> T
  938.               (setf (system-needs-update system) t)
  939.             nil)))))
  940.       ;; no source found
  941.       (let ((bpath (module-binary-file module system)))
  942.         (if (probe-file bpath)
  943.         (if (> (file-write-date bpath) mdtm)
  944.             (setf (system-needs-update system) t)
  945.           nil)
  946.           (error "Module not found ~S." (module-name module)))))
  947.       ;; module not loaded, so certainly it needs to be loaded
  948.       t)))
  949.  
  950. (defun module-needs-reload-p* (module system)
  951.   (or (module-needs-reload-p module system)
  952.       (some #'(lambda (pair)
  953.         (module-needs-reload-p (car pair) (cdr pair)))
  954.         (module-needed-modules*-aux module system))))
  955.  
  956. ;----------------------------------------------------------------------------;
  957. ; module-needs-recompile-p
  958. ;-------------------------
  959. ; return T if module its binary is older than its source
  960.  
  961.  
  962. (defun module-needs-recompile-p (module system)
  963.   (declare (type module module) (type system system))
  964.   (unless (module-not-to-be-compiled module)
  965.     (let ((bpath  (module-binary-file module system)))
  966.       (declare (pathname bpath))
  967.       (when (if (probe-file bpath)
  968.         (< (file-write-date bpath)
  969.            (file-write-date (module-source-file module system)))
  970.           t)
  971.     (setf (system-needs-update system) t)))))
  972.  
  973. (defun module-needs-recompile-p* (module system)
  974.   (or (module-needs-recompile-p module system)
  975.       (some #'(lambda (pair)
  976.         (module-needs-recompile-p (car pair) (cdr pair)))
  977.         (module-needed-modules*-aux module system))))
  978.  
  979. (defun system-needs-recompile-p (system)
  980.   (let (clean-systems)
  981.     (labels ((system-needs-recompile-p-aux (system)
  982.            (if (member system clean-systems)
  983.            nil
  984.          (or (system-needs-update system)
  985.              (some #'(lambda (module-name)
  986.                    (module-needs-recompile-p*
  987.                 (find-module module-name system) system))
  988.                (system-module-list system))
  989.              (some #'(lambda (system-name)
  990.                    (system-needs-recompile-p-aux (find-system system-name)))
  991.                (system-needed-systems system))
  992.              
  993.              (progn (push system clean-systems)
  994.                 ;;   (setf (system-needs-update system) nil)
  995.                 nil)
  996.  
  997.          ))))
  998.     (system-needs-recompile-p-aux system))))
  999.  
  1000. (defun SYSTEM-COMPILED-P (system-name)
  1001.   (not (system-needs-recompile-p (find-system system-name))))
  1002.  
  1003. (defun MODULE-COMPILED-P (module-name 
  1004.               &key ((:system system-name) nil system-p))
  1005.   (declare (symbol system-name))
  1006.   (let (module system)
  1007.     (if system-p
  1008.     (setq system (find-system system-name)
  1009.           module (find-module module-name system))
  1010.       (multiple-value-setq (module system)
  1011.     (find-module-among-systems
  1012.      module-name
  1013.      (mapcar #'car *all-systems*)
  1014.      nil                ; no errors
  1015.      )))
  1016.     (not (module-needs-recompile-p* module system))))
  1017.  
  1018. ;----------------------------------------------------------------------------;
  1019. ; system-needed-systems*
  1020. ;-----------------------
  1021. ; given the name of a defined system, returns the
  1022. ; transitive closure of system-needed-systems
  1023.  
  1024. (defun system-needed-systems* (system-name &optional (recursive-p t))
  1025.   (let ((system (find-system system-name)))
  1026.     (if recursive-p
  1027.     (system-needed-systems*-aux system)
  1028.       (system-needed-systems system))))
  1029.  
  1030. (defun system-needed-systems*-aux (system)
  1031.   (labels ((system-needed-systems*-list (l)
  1032.          (if (null l)
  1033.          nil
  1034.            (union (system-needed-systems*-aux (find-system! (car l)))
  1035.               (system-needed-systems*-list (cdr l))))))
  1036.     (adjoin (system-name system)
  1037.         (system-needed-systems*-list (system-needed-systems system))))
  1038.   )
  1039.  
  1040. (defun module-needed-modules* (module-name system-name &optional (recursive-p t))
  1041.   (let* ((system (find-system system-name))
  1042.      (module (find-module module-name system))
  1043.      (needed-modules (module-load-after module)))
  1044.     (if recursive-p
  1045.     (mapcar #'(lambda (x) (module-name (car x)))
  1046.         (module-needed-modules*-aux module system))
  1047.       needed-modules)))
  1048.  
  1049. (defun module-needed-modules*-aux (module system &aux Acc)
  1050.   (macrolet ((module-set (MS-desc system)
  1051.            ;; MS-desc: (<SYSTEM> m1 m2 ...) || (<SYSTEM> t)
  1052.            `(let ((ms (cdr (the cons ,MS-desc))))
  1053.          (if (eq (car (the cons ms)) 'T)
  1054.              (system-module-list ,system)
  1055.            ms))))             
  1056.     (let ((ns (system-needed-systems*-aux system)))
  1057.       (labels ((module-needed-modules*-aux-0 (module-name All-ns)
  1058.          ;;(format t "~%-aux-0 ~S ~S ~%~S" module-name All-ns Acc)
  1059.          (unless (find-if
  1060.               #'(lambda (pair)
  1061.                   (string= (module-name (car pair)) module-name))
  1062.               Acc)
  1063.            (multiple-value-bind (mod system)
  1064.                (find-module-among-systems module-name All-ns t)
  1065.              ;; avoid recursion if modules need themselves
  1066.              (unless (assoc mod Acc)
  1067.                (push (cons mod system) Acc)
  1068.                (module-needed-modules*-aux-1 mod All-ns)))))
  1069.            (module-needed-modules*-aux-1 (module All-ns)
  1070.          ;;(format t "~%-aux-1 ~S ~S~%~S" module All-ns Acc)
  1071.          (dolist (module-descr (module-load-after module))
  1072.            (if (stringp module-descr)
  1073.                (module-needed-modules*-aux-0 module-descr All-ns)
  1074.              (let* ((system-name (car (the cons module-descr)))
  1075.                 (system (find-system system-name))
  1076.                 (new-All-ns (union (system-needed-systems system)
  1077.                            (adjoin system-name All-ns))))
  1078.                (dolist (module-name (module-set module-descr system))
  1079.              (unless (module-not-to-be-loaded
  1080.                   (find-module module-name system))
  1081.                (module-needed-modules*-aux-0
  1082.                 module-name new-All-ns))))))))
  1083.     (module-needed-modules*-aux-1 module ns)
  1084.     (nreverse Acc)))))
  1085.  
  1086. (defun find-module (m s &optional (errorp t))
  1087.   (declare (type system s))
  1088.   (setq m (string m))
  1089.   (let ((md (gethash m (system-modules s))))
  1090.     (if md
  1091.     md
  1092.       (when errorp (error "Module ~S not present in System ~S.~%"
  1093.               m s))
  1094.       )))
  1095.  
  1096. (defun find-module-among-systems (m systems &optional (errorp t))
  1097.   ;; systems : (list x:symbol)
  1098.   (dolist (system-name systems)
  1099.     (let ((system (find-system system-name errorp)))
  1100.       (when system
  1101.     (let ((module (find-module m system nil)))
  1102.       (when module
  1103.           (return-from find-module-among-systems
  1104.         (values module system)))))))
  1105.   (when errorp
  1106.     (error "Module ~S not present in Systems ~S.~%"
  1107.        m systems)))
  1108.  
  1109. ;----------------------------------------------------------------------------;
  1110. ; find-system
  1111. ;------------
  1112.  
  1113. (defun find-system (system-name &optional (errorp t))
  1114.   (let ((system-entry (assoc system-name *all-systems*)))
  1115.     (if system-entry
  1116.     (cdr system-entry)
  1117.       (when errorp
  1118.     (error "No ~S system description found!"
  1119.            system-name))
  1120.       )))
  1121.  
  1122. (defun find-system! (system-name)
  1123.   (or (find-system system-name nil)
  1124.       (load-system-definition system-name))
  1125.   )    
  1126.   
  1127. (defvar *system-directories* ())
  1128. (defun find-system-definition-file (system-name &optional (errorp t))
  1129.   (let ((filename (format nil "~A-sys" (string system-name))))
  1130.     (dolist (pathname (if (null *default-pathname-defaults*)
  1131.               *system-directories*
  1132.             (cons *default-pathname-defaults* *system-directories*)))
  1133.       (setq pathname (expand-file-name
  1134.               (typecase pathname
  1135.             (string pathname)
  1136.             (pathname (namestring pathname))
  1137.             (t (warn "~S is neither a string nor a pathname." pathname)
  1138.                (return)))))               
  1139.       (let ((binary-file (merge-pathnames
  1140.               (merge-pathnames filename
  1141.                        pathname)
  1142.               (make-pathname :type (cdr *suffixes*))))
  1143.         (source-file (merge-pathnames
  1144.               (merge-pathnames filename
  1145.                        pathname)
  1146.               (make-pathname :type (car *suffixes*)))))
  1147.     ;; (format t "~%~S~%~S" binary-file source-file)
  1148.     (cond ((and (probe-file binary-file)
  1149.             (probe-file source-file))
  1150.            (return-from find-system-definition-file
  1151.                 (if (> (file-write-date binary-file)
  1152.                    (file-write-date source-file))
  1153.                   binary-file
  1154.                   source-file)))
  1155.           ((probe-file binary-file)
  1156.            (return-from find-system-definition-file
  1157.                 binary-file))
  1158.           ((probe-file source-file)
  1159.            (return-from find-system-definition-file
  1160.                 source-file))
  1161.           ((probe-file (merge-pathnames filename pathname))
  1162.            (return-from find-system-definition-file
  1163.                 (merge-pathnames filename pathname))))))
  1164.     (when errorp
  1165.       (system-definition-not-found system-name))))
  1166.  
  1167. (defun load-system-definition (system-name &key (errorp t))
  1168.   ;; load the system-definition
  1169.   ;; return system-entry if successful
  1170.   ;; nil otherwise
  1171.   (let ((system-def (find-system-definition-file system-name errorp)))
  1172.     (if system-def
  1173.     (progn
  1174.       (format t "~%;;; Loading definition for system ~A from ~S"
  1175.           system-name system-def)
  1176.       (load system-def)
  1177.       (let ((system-entry (assoc system-name *all-systems*)))
  1178.         (if  system-entry
  1179.         (cdr system-entry)
  1180.           (when errorp
  1181.         (error "No ~S system definition loaded."
  1182.                system-name)))))
  1183.       (when errorp (system-definition-not-found system-name))))
  1184.   )
  1185. ;----------------------------------------------------------------------------;
  1186. ; system-loaded-p
  1187. ;----------------
  1188. ; returns two values: value1                          value2
  1189. ;                     T if  system is loaded          T if system is loaded
  1190. ;                                                       and needs reload
  1191. ;                     Nil   otherwise                 
  1192.  
  1193. (defun SYSTEM-LOADED-P (system-name)
  1194.   (declare (symbol system-name))
  1195.   (let ((loaded? (member system-name *loaded-systems*))
  1196.     (system (find-system system-name)))
  1197.     (if loaded?
  1198.     (dolist (ss (system-needed-systems*-aux system)
  1199.          (values t nil))
  1200.       (let ((subsystem (find-system ss)))
  1201.         (dolist (module (let ((lm (system-default-load-module subsystem)))
  1202.                   (if (eq lm 'T)
  1203.                   (system-module-list subsystem)
  1204.                 (if (consp lm)
  1205.                     lm
  1206.                   (list lm)))))
  1207.           (when (module-needs-reload-p*
  1208.              (find-module module subsystem) subsystem)
  1209.         (return-from SYSTEM-LOADED-P
  1210.           (values t (setf (system-needs-update system) t)))))))
  1211.       nil)))
  1212.     
  1213.  
  1214. ;----------------------------------------------------------------------------;
  1215. ; MODULE-LOADED-P
  1216. ;----------------
  1217. ; returns two values: value1                          value2
  1218. ;                     T if  module is loaded          T if module is loaded
  1219. ;                                                       and needs reload
  1220. ;                     Nil   otherwise                 
  1221.  
  1222. (defun MODULE-LOADED-P (module-name
  1223.             &key ((:system system-name) nil system-p))
  1224.   (declare (symbol system-name))
  1225.   (let (module system)
  1226.     (if system-p
  1227.     (setq system (find-system system-name)
  1228.           module (find-module module-name system))
  1229.       (multiple-value-setq (module system)
  1230.     (find-module-among-systems
  1231.      module-name
  1232.      (mapcar #'car *all-systems*)
  1233.      nil   ; no errors
  1234.      )))
  1235.     (if module
  1236.     (let ((loaded? (module-loaded module)))
  1237.       (values loaded?
  1238.           (and loaded?
  1239.                (module-needs-reload-p* module system))))
  1240.       (values nil nil))))
  1241.  
  1242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1243. ;;                                   errors
  1244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1245.  
  1246.  
  1247. (defun system-definition-not-found (system-name)
  1248.   (declare (symbol system-name))
  1249.   (error "A definition was not found for system ~A~%; looking for file ~A-sys in: ~{~S ~}."
  1250.      system-name (symbol-name system-name) *system-directories*))
  1251.  
  1252. (defun module-not-found (module system)
  1253.   (error "Can't find any file for module named ~S in system ~S."
  1254.      (module-name module) (system-name system))
  1255.   )
  1256.  
  1257. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1258. ;;                               cycle detection
  1259. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1260.  
  1261. (defun system-circular-p (system-name link)
  1262.   (let* ((system (find-system system-name))
  1263.      (context (cons system-name (system-needed-systems system)))
  1264.      (*print-circle* nil))
  1265.     (dolist (m (system-module-list system))
  1266.       (let ((cycle (detect-1-cycle
  1267.             (find-module m system)
  1268.             context
  1269.             nil
  1270.             (case link
  1271.               (:load-after #'module-load-after)
  1272.               (:load-before-compile #'module-load-before-compile)))))
  1273.     (when cycle
  1274.       (format t "~%;;; Warning: Circularity: ~S" cycle))))))
  1275.  
  1276. (defun detect-1-cycle (node context path get-children)
  1277.   ;; node:MODULE  path : ( STRING .. )
  1278.   ;; context : { SYSTEM | ( SYSTEM .. ) }
  1279.   (labels ((detect-1 (node context path)
  1280.          (let* ((mname (module-name node))
  1281.             (rpath (member mname path :test #'STRING=)))
  1282.            (if rpath
  1283.            (progn ;; (break)
  1284.               (setf (cdr rpath) nil)
  1285.               (return-from detect-1-cycle (cons mname path)))
  1286.          (let ((new-path (cons mname path)))
  1287.            (dolist (child (funcall get-children node))
  1288.              ;; child : { string | (<SYSTEM> string ..) | (<SYSTEM> t) }
  1289.              (if (consp child)
  1290.              (let ((system (find-system (car (the cons child)) nil)))
  1291.                (when system
  1292.                  (let ((context (list system)))
  1293.                    (dolist (gchild (if (eq (cadr child) 'T)
  1294.                            (system-module-list system)
  1295.                          (rest child)))
  1296.                  (let ((gchild-module (find-module gchild system)))
  1297.                    (when gchild-module
  1298.                      (detect-1 gchild-module
  1299.                            context
  1300.                            new-path)))))))
  1301.                (multiple-value-bind (child-module system)
  1302.                (find-module-among-systems child context nil)
  1303.              (when child-module
  1304.                (detect-1 child-module
  1305.                      (cons (system-name system)
  1306.                        (system-needed-systems system))
  1307.                      new-path))))))))))
  1308.     (detect-1 node context path)))
  1309.  
  1310. #||
  1311. (defsystem foo
  1312.     ()
  1313.   ("foo" :load-after "bar")
  1314.   ("bar" :load-after "baz")
  1315.   ("baz" :load-after "foo")
  1316.   )
  1317. (system-circular-p 'foo ':load-after) 
  1318. (system-circular-p 'foo ':load-always) 
  1319.  
  1320. (defsystem fie
  1321.     ()
  1322.   ("foo" :load-after "bar")
  1323.   ("bar" :load-after ((fum "baz")))
  1324.   )
  1325.  
  1326. (defsystem fum
  1327.     ()
  1328.   ("baz" :load-after ((fie t)))
  1329.   )
  1330.  
  1331. (show-system 'fie)
  1332. (show-system 'fum)
  1333. ||#
  1334.  
  1335. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1336. ;;                               end of defsys.l
  1337. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1338.